C  *****  NSCTPY  JUL 16 71 ******  WRITES ON MAGTAPE OR DSK.  NO SCOPE!
C  ****** LOAD WITH TAPOUT.REL  *********
C   TO WRITE ON DSK: BIGBIT←1; OR RCDFLG←1;    TO WRITE ON TAPE: BIGBIT←-1;
C  BIGBIT←>1; WRITES ON DSK, 4TH LETTER OF NAME IS SET BY NUMBER.
C   IF RCDFLG IS NOT 0 OR 1, ONE LONG FILE IS WRITTEN. PLAY WITH 'PLAY'.
	SUBROUTINE SMPLS(LSBUF,ISBCNT,IBOTT,MAXAMP,BIGBIT,RCDFLG)
	COMMON JSB(10)
	DIMENSION MX(3),INM(3),MZ(4),IBOTT(1),MQ(5)
	EQUIVALENCE (JSB(3),JSB3),(JSB(4),JSB4),(JSB(5),JSB5)
	DATA (MX(JSC),JSC=1,2)/'AMPL.=0 /'/,INM(2)/' AMP='/
	DATA (MZ(K),K=1,3)/'ADJUST LSBUF!**'/
	DATA JSAVE/33000/
	IF(J)GO TO 6
86	K=-1
   	IEND=-1
	LNM=0
	NUM=0
	IMAX=50000
	IF(BIGBIT.EQ.0)GO TO 8
	IF(RCDFLG.GT.8000)JSAVE=RCDFLG
	RCDFLG=0
C   WILL SAVE AFTER C.33K UNLESS RCDFLG>8K
87	IF(BIGBIT.LT.0)GO TO 88
	IF(BIGBIT.LT.1)GO TO 8
	JSC=BIGBIT-1.
	LNM='MUSAA'+256*JSC
	BIGBIT=.5
C  NAME CHANGE ONLY WORKS WHEN WRITING ON DSK.
	J=0
	GO TO 87
88	K=0
CC	CALL MESS(MZ)
	KBIT=2
	GO TO 9
8	KBIT=3.-BIGBIT
	IF(RCDFLG.GT.1.)RCDFLG=-1.
9	IF(RCDFLG.NE.-1)IBOTT(1024)=0
	JSB(2)=KBIT
C   KBIT=3, 12-BITS.  KBIT=2, 18-BITS. JSB(2) PASSES KBIT TO CONVRT.
	IF(J.EQ.1)GO TO 5
	JNM='MUSAA'
	IF(LNM.NE.0)JNM=LNM
1	INM(1)=JNM
	KNM=JNM
	J=1
5	IF(INM(1).LE.JNM+50)GO TO 2
	JNM=JNM+256
	IF(JNM.LE.KNM+6400)GO TO 3
	KNM=JNM+26112
	JNM=KNM
C   RAISES 'AAAZA' TO 'AABAA'
3	INM(1)=JNM
C   NAMES GO FROM 'AAAAA' TO 'AAZZZ': MUSAA,MUSAB,MUSAC,ETC.
2	IF(K)GO TO 33
	CALL GETTAP
	GO TO 34
33	CALL PUTFIL(INM(1))
34	J=-1
	JSC=LSBUF
C  IF RCDFLG←-1; LSBUF=1024 -- OTHERWISE LSBUF=1023 AND LAST WD(1024) IS AMP.
	IF(RCDFLG)GO TO 666
	JSC=LSBUF+1
C  WRITES LSBUF+1 WDS.  THE '+1' WILL HAVE MAXAMP IN LAST BUFFER.
	JSB(1)=JSC
	JSB3=INM(1)
	JSB4=9999
	JSB5=9998
	IF(K)GO TO 66
	CALL TOTAPE(JSB(1),128)
	GO TO 6
C666	JSC=1024
666	IMAX=2050
	GO TO 6
66	CALL FASTOU(JSB(1),128)
6	IF(ISBCNT.NE.0)GO TO 7
	IF(NUM+LSBUF.LT.JSAVE.OR.RCDFLG)GO TO 4
10	IBOTT(JSC)=MAXAMP
	IF(MAXAMP.EQ.0)IBOTT(JSC)=1
C  IF 0, THEN NO WAY TO FIND END OF FILE IN OTHER PROGS.
5444	IEND=0
	GO TO 4
7	IF(RCDFLG)GO TO 5444
	IBOTT(LSBUF)=(ISBCNT-1)/KBIT       
	MAXAMP=-MAXAMP
C  LAST WRD OF LSBUF IS USED FOR WDCNT OF FREE SPACE IN LAST BUFFER.
C  -MAXAMP TELLS CONVRT IT'S THE LAST BUFFER.
	GO TO 10
4	NUM=NUM+LSBUF
	IF(MAXAMP.EQ.0)CALL MESS(MX)
CC	GO TO 4444
	IF(MAXAMP.LT.IMAX)GO TO 4444
C  IABS(MAXAMP) WON'T WORK 1ST TIME AROUND!!!!!!!⊗⊗⊗⊗⊗⊗⊗⊗⊗⊗⊗
C   49999 IS MAXIMUM AMPL. POSSIBLE (ARBITRARY NUMBER.)
	CALL MESS(INM)
	CALL MESS(INM)
	CALL MESS(INM)
	CALL MESS(INM)
	CALL PNUM(MAXAMP)
        GO TO 227
4444	IF(K)GO TO 44
	 CALL TOTAPE(IBOTT(1),JSC)
	GO TO 45
44	CALL FASTOU(IBOTT(1),JSC)
45	IF(IEND)RETURN
	IF(RCDFLG)GO TO 224
22	JSB(1)=-1
	JSB3=INM(1)
	JSB4=9999
	JSB5=9998
	IF(K)GO TO 222
	CALL TOTAPE(JSB(1),128)
C    '-1' MARKS END OF THIS BATCH OF DATA.
C    '9999' IDENTIFIES IT AS MUSIC DATA WHEN TAPE IS READ.
	CALL FINTAP
	CALL BACKSP
	CALL BACKSP
	GO TO 223
224	K=NUM/LSBUF
	J=0
	NUM=4-K-(K/4*4)
C  MAKES MULTIPLES OF 4K.
	J=0
CC	IF(NUM.EQ.0)GO TO 2221
2251	DO 225 K=1,1024
225	IBOTT(K)=0
2261	DO 226 K=1,NUM
226	CALL FASTOU(IBOTT(1),LSBUF)
227	CALL FINFIL
	GO TO 2221
222	CALL FASTOU(JSB(1),128)
	CALL FINFIL
223	J=1
2231	IF(RCDFLG.GE.0)CALL SAVER
	JSB(1)=0
2221	CALL MESS(INM)
	CALL PNUM(MAXAMP)
	INM(1)=INM(1)+2
	RETURN
	END


C  ********** SEG  --  *********

	SUBROUTINE SEG(FUNC)
C  TYPE AMPL, STEP# (UP TO STEP 512). ---- SAME FORMAT AS GEN 1 IN MUSIC5.
	DIMENSION FUNC(512),A(4)
	COMMON K,STEP,AMP1,AMP2,DIF,IT,IS,ST,STPS,RK
	DATA (A(K),K=1,3)/'SEG ARRAY FULL/'/
	AMP1=0
	ST=0
1	CALL RDNUM(AMP2)
	CALL RDNUM(STEP)
	IF(STEP.GT.1.)GO TO 3
	AMP1=AMP2
	GO TO 1
C  STEP=1 AND STEP=0 ARE CONSIDERED THE SAME.
3	DIF=AMP2-AMP1
5	IT=ST
	IS=STEP*5.120+.0001
	STEP=IS
 	STPS=STEP-ST
	IS=STPS
	IF(IS+IT.GT.512)GO TO 6
	ST=STEP
	IF(ST.EQ.0)STEP=1.
	DO 2 K=1,IS
CC	M=K+IT
	RK=K
2	FUNC(K+IT)=AMP1+DIF*RK/STPS
	AMP1=AMP2
      	ST=STEP
CC	CALL PNUM(M)
	IF(STEP.LT.512)GO TO 1
CC	IF(STEP.GT.513.)GO TO 6
1102	CALL MESS(A)
CC*** WHY WAS THIS HERE????	FUNC(1)=0.0
	RETURN
6	K=1
8	CALL RDNUM(RK)
7	FUNC(K)=RK
	K=K+1
	IF(K.LE.512)GO TO 8
	GO TO 1102
	END

	SUBROUTINE SYNTH (FUNC)
C  AFTER 'SYNTH(F1);'  TYPE 99= TO USE  H,A,P,K: ALL OTHER
C   NUMBERS = H,A ONLY.  TYPE 999 TO END. NORMALIZATION IS AUTOMATIC.
	DIMENSION FUNC(512),F(5)
	COMMON I,XX,X,H,K,CON,XK,FAC,AMP,Y
	DATA (F(I),I=1,4)/'SYNTH ARRAY FULL/'/
	DO 15 I=1,512
15	FUNC(I)=0.0
 	CALL RDNUM(XX)
	IF(XX.EQ.99)XX=-99
	FAC=360./512.
	H=XX
	IF(XX)CALL RDNUM(H)
16	CALL RDNUM(AMP)
	IF(XX)GO TO 1016
	X=0
	CON=0
	GO TO 2016
1016	CALL RDNUM(X)
	X=X*512./360.+1.0
	CALL RDNUM(CON)
2016	DO 17 J=1,512
	XK=SIND(X*FAC)*AMP+CON
	IF(CON.LT.100.0)GO TO 1
	FUNC(J)=(XK-100.)*FUNC(J)
	GO TO 2
1	FUNC(J)=FUNC(J)+XK
2	X=X+H
	IF(X.LE.512.)GO TO 17
	X=X-512.
17	CONTINUE
	CALL RDNUM(H)
	IF(H.NE.999.)GO TO 16
2200	X=FUNC(1)
	DO 19 I=2,512
	H=ABS(FUNC(I))
19	IF(X.LT.H)X=H
	DO 20 I=1,512
20	FUNC(I)=FUNC(I)/X
	CALL MESS(F)
	RETURN
	END
C   ***********  DUR2 1969  *********
	FUNCTION DUR(P2,SPEED,CHNS)
	COMMON P,ISR,NC,IDUR,ID,IP(5)
	DATA IP/20000,25000,10000,50000,100000/
	P=P2
	ISPD=SPEED
	NC=CHNS*30+.3
3	IDUR=P*10000+.5
5	IDUR=(IDUR*IP(ISPD))/1000
6	ID=IDUR/NC
7	ID=IDUR-ID*NC
	IF(ID.EQ.0)GO TO 1
	P=P+.0001
	GO TO 3
1	DUR=P
	RETURN
	END


	SUBROUTINE SEE(FUNC)

	DIMENSION FUNC(512),SU(150),C(3)
 	DATA (C(I),I=1,2)/'0=CLEAR: '/
CC	CALL DDCLR
C  THIS VERSION MUST BE LOADED WITH %LTVRLIB (FOR 'DDCLR')
CC	CALL TYPLOC(-300,-512)
	CALL DPYSET(2,SU,150)
CC	CALL DPYBRT(6)
	CALL ALINE(-264,0,256,0)
	CALL ALINE(-256,-256,-256,256)
	CALL AIVECT(0,0)
1	IY=FUNC(1)*256.0
	CALL AIVECT(-256,IY)
	DO 14 I=2,512,3
	IY2=FUNC(I)*256.0
	CALL RVECT(3,IY2-IY)
14	IY=IY2
	CALL DPYOUT(2)
100	CALL MESS(C)
1100   	CALL RDNUM(X)
	CALL DPYCLR
	RETURN
	END

	FUNCTION POWER(X,Y)
	POWER=EXP(Y*ALOG(X))
	RETURN
	END